home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Network Support Library
/
RoseWare - Network Support Library.iso
/
apidev
/
basnet.arc
/
FONEDIR.BAS
< prev
next >
Wrap
BASIC Source File
|
1987-05-07
|
16KB
|
460 lines
100 ' FONEDIR.BAS
110 '
120 ' demonstrates the use of locks
130 '
140 e$=" "
500 OPEN "fone.dir" AS #1 LEN = 48
510 FIELD #1, 4 AS NEXTREC$, 44 AS FILLER$
520 FIELD #1, 30 AS NOMBRE$, 3 AS AREA$, 7 AS NMBR$, 4 AS EXTENTION$
530 FIELD #1, 48 AS ZAPIT$
600 'set up file if necessary
610 IF LOF(1) < 48 THEN LSET NEXTREC$ = "2": LSET FILLER$ = STRING$(44,"x") : PUT #1,1
700 'set up net access
710 gosub 10000
720 'get the file handle for later use
730 gosub 11000
1000 '
1001 ' this routine displays the menu
1002 '
1003 CLS
1005 LOCATE 3,20
1007 PRINT " PHONE DIRECTORY PROGRAM"
1015 LOCATE 5,20
1021 PRINT "************* MAIN MENU ************"
1022 LOCATE 6,20
1023 PRINT "* *"
1025 LOCATE 7,20
1030 PRINT "* 1. Display Current Directory *"
1035 LOCATE 8,20
1040 PRINT "* *"
1045 LOCATE 9,20
1050 PRINT "* 2. Add a Directory Entry *"
1055 LOCATE 10,20
1060 PRINT "* *"
1065 LOCATE 11,20
1070 PRINT "* 3. Modify a Directory Entry *"
1075 LOCATE 12,20
1080 PRINT "* *"
1085 LOCATE 13,20
1090 PRINT "* 4. Delete an Entry *"
1095 LOCATE 14,20
1100 PRINT "* *"
1105 LOCATE 15,20
1120 PRINT "* 5. Exit *"
1122 LOCATE 16,20
1125 PRINT "* *"
1126 LOCATE 17,20
1127 PRINT "************************************"
1130 LOCATE 20,20
1140 PRINT "Enter Selection > <"
1150 SELECT$ = ""
1160 LOCATE 20,37,1
1170 WHILE SELECT$ < "1" OR SELECT$ > "5" : SELECT$ = INKEY$ : WEND
1180 SELECT = VAL(SELECT$)
1190 ON SELECT GOSUB 2000,3000,4000,5000,6000
1200 GOTO 1000
2000 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
2001 'routine to display the directory
2002 '
2003 on error goto 16000
2010 GET #1,1
2012 if Err <> 0 then err = 0 : goto 2999
2015 on error goto 0
2020 MAXREC = VAL(NEXTREC$)
2022 CLS
2025 PRINT SPC(23) "PHONE DIRECTORY"
2027 PRINT SPC(23) "---------------"
2033 PRINT "Rec # Person's Name Phone Number Ext."
2036 PRINT "----- ------------------------------ -------------- ------"
2040 FOR COUNT = 2 TO (MAXREC - 1)
2042 noerr = 0
2045 on error goto 15000
2047 GET #1,COUNT
2048 if noerr <> 0 then goto 2100
2050 locate (count + 4),1:PRINT (count - 1);:locate (count + 4),10
2060 PRINT NOMBRE$;
2070 PRINT " " + "(" + AREA$ + ") ";
2080 PRINT LEFT$(NMBR$,3) + "-" + RIGHT$(NMBR$,4);
2090 PRINT " " + "<" + EXTENTION$ + ">"
2095 on error goto 0
2100 NEXT
2110 PRINT: PRINT: PRINT "Press any key to return to the menu.";
2120 WHILE INKEY$ = "": WEND
2999 RETURN
3000 '
3001 ' routine to add a new record to the file
3002 '
3010 ' first we print the entry screen
3020 GOSUB 7000
3025 LOCATE 2,34:PRINT "ADD A RECORD"
3030 ' now go collect the data
3040 GOSUB 8000
3050 'lock the header record and get the next available record
3051 recno% = 1 'the header record
3053 gosub 13000 ' lock it
3055 if ErrCode% <> 0 then goto 3999
3060 GET #1,recno%
3070 NEXTREC = VAL(NEXTREC$)
3080 ' set it up and write it out
3090 LSET NOMBRE$ = TEMPNAME$ : LSET AREA$ = TEMPAREA$ : LSET NMBR$ = TEMPNMBR$ : LSET EXTENTION$ = TEMPEXT$
3092 recno% = nextrec
3095 gosub 13000 'lock the record
3100 PUT #1,NEXTREC
3105 gosub 14000 'release the record lock
3110 'increment the next record pointer
3120 TEMPREC$ = STR$(NEXTREC+1)
3130 LSET NEXTREC$ = TEMPREC$ :LSET FILLER$ = STRING$(44,"x")
3140 PUT #1,1
3150 recno% = 0 'set up for the header record
3160 gosub 14000 ' release the record lock on the header
3999 RETURN
4000 '
4001 'routine to modify an entry
4002 '
4010 'get the record to be modified
4020 CLS
4025 LOCATE 2,32:PRINT "CHANGE A RECORD"
4030 LOCATE 10,1:PRINT USING "&";E$:LOCATE 10,20
4040 INPUT "What record do you wish to change? =>",RECNO$
4041 IF VAL(RECNO$) = 0 THEN LOCATE 12,1:PRINT USING "&";E$:LOCATE 12,22:PRINT "*** Your entry is not numeric ***":goto 4030
4050 recno% = VAL(recno$)
4060 recno% = recno% + 1 'treat the first record as record 0
4063 gosub 13000 'log and lock the record
4064 if ErrCode% <> 0 then goto 4999
4070 GET #1,recno%
4080 'now print the entry screen
4090 GOSUB 7000
4100 'next print the data from the record to be modified
4105 LOCATE 2,32:PRINT "CHANGE A RECORD"
4110 LOCATE 6,44
4120 PRINT NOMBRE$
4130 LOCATE 11,32
4140 PRINT AREA$
4150 LOCATE 16,24
4160 PRINT left$(NMBR$,3)
4162 locate 16,30
4165 print mid$(nmbr$,4,4)
4170 LOCATE 21,32
4180 PRINT EXTENTION$
4190 ' now get the replacement data
4200 GOSUB 8000
4210 ' set it up and write it out
4220 if tempname$ <> "" then LSET NOMBRE$ = TEMPNAME$
4221 if temparea$ <> "" then LSET AREA$ = TEMPAREA$
4222 if tempnmbr$ <> "" then LSET NMBR$ = TEMPNMBR$
4223 if tempext$ <> "" then LSET EXTENTION$ = TEMPEXT$
4230 PUT #1,recno%
4240 gosub 14000 ' clear the record lock
4999 RETURN
5000 '
5001 'routine to delete an existing record
5002 '
5010 'get the record to be deleted
5020 CLS
5025 LOCATE 2,32:PRINT "DELETE A RECORD"
5030 LOCATE 10,1:PRINT USING "&";E$:LOCATE 10,20
5040 INPUT "What record do you wish to delete? =>",RECNO$
5041 IF VAL(RECNO$)=0 THEN LOCATE 12,1:PRINT USING "&";E$:LOCATE 12,22:PRINT "*** Your entry is not numeric ***":goto 5030
5050 recno% = VAL(recno$)
5060 recno% = recno% + 1 ' treat the first record as record 0
5065 gosub 13000 'lock the record
5068 if ErrCode% <> 0 then goto 5999
5070 GET #1,recno%
5080 'display the record to be deleted
5090 'print the screen
5100 GOSUB 7000
5105 LOCATE 2,32:PRINT "DELETE A RECORD"
5110 'print the data
5120 GOSUB 9000
5130 'provide a chance to bail out
5140 LOCATE 24,15
5150 PRINT "PRESS Y TO DELETE THIS RECORD, N TO ABORT. ";
5160 DOIT$ = ""
5170 WHILE DOIT$ <> "Y" AND DOIT$ <> "y" AND DOIT$ <> "n" AND DOIT$ <> "N" : DOIT$ = INKEY$ :WEND
5180 IF DOIT$ <> "Y" AND DOIT$ <> "y" THEN gosub 14000: RETURN
5190 LSET ZAPIT$ = "* deleted *" + STRING$(53," ")
5200 PUT #1,recno%
5210 gosub 14000 ' release the lock
5999 RETURN
6000 '
6001 'exit routine
6002 '
6010 CLOSE 1
6020 SYSTEM
6999 RETURN
7000 '
7001 'routine to print the entry screen
7002 '
7010 CLS
7050 LOCATE 5,10
7060 PRINT "Person's Name (up to 30 letters) <______________________________>"
7070 LOCATE 10,10
7100 PRINT "Area Code (3 digits) <___>"
7110 LOCATE 15,10
7120 PRINT "Phone Number <___>-<____>"
7130 LOCATE 20,10
7140 PRINT "Extension (4 digits) <____>"
7999 RETURN
8000 '
8001 'collect the data
8002 '
8003 LOCATE 5,44 :TEMPNAME$ = ""
8004 valnam$ = ""
8005 WHILE VALNAM$ = "":VALNAM$ = INKEY$:WEND
8007 locate 5,(len(tempname$)+44)
8009 IF VALNAM$ = chr$(13) THEN 8032
8010 LOCATE 5,(LEN(TEMPNAME$)+44):print valnam$
8020 TEMPNAME$ = TEMPNAME$ + VALNAM$
8025 IF LEN(TEMPNAME$) < 31 THEN locate 5,(Len(Tempname$)+44):goto 8004
8032 y%=32
8035 x%=10
8037 TEMPAREA$ = ""
8040 LOCATE 10,32
8042 vallen%=3
8045 errloc% = 12
8050 gosub 17000
8057 LOCATE errloc%,10:PRINT e$
8060 TEMPAREA$ = NUMBVAL$
8065 Y%=24:X%=15
8070 LOCATE X%,Y%
8071 TEMPNMBR$ = ""
8072 VALLEN%=3
8075 ERRLOC%=17
8077 GOSUB 17000
8080 LOCATE errloc%,10:PRINT e$
8081 TEMPNMBRLFT$=NUMBVAL$
8082 X%=15:Y%=30
8083 LOCATE X%,Y%
8084 VALLEN%=4
8085 ERRLOC%=17
8086 GOSUB 17000
8088 LOCATE errloc%,10:PRINT e$
8089 TEMPNMBRRHT$ = NUMBVAL$
8090 TEMPNMBR$ = TEMPNMBRLFT$ + TEMPNMBRRHT$
8100 X%=20:Y%=32
8101 TEMPEXT$ = ""
8102 LOCATE X%,Y%
8103 VALLEN% = 4
8104 ERRLOC% = 22
8106 GOSUB 17000
8107 LOCATE errloc%,10:PRINT e$
8110 TEMPEXT$ = NUMBVAL$
8999 RETURN
9000 '
9001 ' routine to fill in data on the entry screen for delete routine
9002 '
9010 LOCATE 5,44
9020 PRINT LEFT$(NOMBRE$,LEN(NOMBRE$))
9030 LOCATE 10,32
9040 PRINT AREA$
9050 LOCATE 15,24
9060 PRINT left$(NMBR$,3)
9062 locate 15,30
9065 print mid$(nmbr$,4,4)
9070 LOCATE 20,32
9080 PRINT EXTENTION$
9999 RETURN
10000 '
10010 ' routines for network use
10020 '
10100 ' This section contains the routine names and
10101 ' offsets for the BASNET library
10102 ' the return is after everything is set up for NetWare calls
10110 XTNDOPN = 0 'xtndopn(Mode%, Filename$, Handle%, ErrCode%)
10111 SETATTR = 3 'setattr(Func%, Filename$, Attribute%, ErrCode%)
10112 EOJSTAT = 6 'eojstat(Flag%)
10113 PRLH.LOG = 9 'PRLH.Log(FileHandle%,HiByteOffset%,LoByteOffset%,HiLockLen%,LoLockLen%,Flags%,TimeOut%,ErrCode%)
10114 PRLH.REL = 12 'PRLH.Rel(FileHandle%,HiByteOffset%,LoByteOffset%,ErrCode%)
10115 PRLH.CLR = 15 'PRLH.Clr(FileHandle%,HiByteOffset%,LoByteOffset%,Errcode%)
10116 PRLF.LOG = 18 'PRLF.Log(fcb%,HiByteOffset%,LoByteOffset%,HiLockLen%,LoLockLen%,Flags%,TimeOut%,ErrCode%)
10117 PRLF.REL = 21 'PRLF.Rel(fcb%,HiByteOffset%,LoByteOffset%,ErrCode%)
10118 PRLF.CLR = 24 'PRLF.Clr(fcb%,HiByteOffset%,LoByteOffset%,ErrCode%)
10119 PRLS.LCK = 27 'PRLS.Lck(Flags%,TimeOut%,ErrCode%)
10120 PRLS.REL = 30 'PRLS.Rel(ErrCode%)
10121 PRLS.CLR = 33 'PRLS.Clr(ErrCode%)
10122 OPENSEM = 36 'OpenSem(Sema4$,SemaValu%,HiHandle%,LoHandle%,OpenCnt%,RetCode%)
10123 EXAMSEM = 39 'ExamSem(HiHandle%,LoHandle%,SemaValu%,OpenCnt%,RetCode%)
10124 WAITSEM = 42 'WaitSem(HiHandle%,LoHandle%,TimeOut%,RetCode%)
10125 SIGSEM = 45 'SigSem(HiHandle%,LoHandle%,RetCode%)
10126 CLOSSEM = 48 'ClosSem(HiHandle%,LoHandle%,RetCode%)
10127 SETLCK = 51 'setlck(Func%,Mode%)
10128 BAKOUTS = 54 'Bakouts(Func%,RetCode%)
10129 BTRANS = 57 'btran(ReturnCode%, Mode%)
10130 ETRANS = 60 'etrans(ReturnCode%)
10131 EXCLOG = 63 'exclog(ReturnCode%, FcbAddr)
10132 EXCLCKS = 66 'exclcks(ReturnCode%, Mode%)
10133 EXCULKF = 69 'exculkf(ReturnCode%, FcbAddr)
10134 EXCULKS = 72 'exculks(ReturnCode%)
10135 EXCCLRF = 75 'excclrf(ReturnCode%, FcbAddr)
10136 EXCCLRS = 78 'excclrs(ReturnCode%)
10137 RECLOG = 81 'reclog(ReturnCode%, String$)
10138 RECLCK = 84 'reclck(ReturnCode%, Mode%)
10139 RECULK = 87 'reculk(ReturnCode%, Semaphore$)
10140 RECULKS = 90 'reculks(ReturnCode%)
10141 RECCLR = 93 'recclr(ReturnCode%, Semaphore$)
10142 RECCLRS = 96 'recclrs(ReturnCode%)
10143 EOJ = 99 'eoj(ReturnCode%)
10144 SYSOUT = 102 'sysout(ReturnCode%)
10145 ALLOCR = 105 'allocr(ReturnCode%, Resource%)
10146 DALLOCR = 108 'dallocr(ReturnCode%, Resource%)
10147 VOLSTAT = 111 'volstat(volume%, reply$)
10148 LOCDRV = 114 'locdrv(NumDisks%)
10149 WSID = 117 'wsid(ThisStationNum%)
10150 ERRMODE = 120 'errmode(mode%)
10151 BCSMODE = 123 'bcsmode(mode%)
10152 CTLSPL = 126 'ctlspl(mode%)
10153 SPLREQ = 129 'splreq(ErrCode%, RequestBlock$, Reply$)
10154 PIPREQ = 132 'pipreq(ErrCode%, RequestBlock$, Reply$)
10155 DPATH = 135 'dpath(ReturnCode%, RequestBlock$, Reply$)
10156 SYSLOG = 138 'syslog(ReturnCode%, RequestBlock$, Reply$)
10157 FATTR = 141 'fattr(ReturnCode%, FcbAddr, Attribute%)
10158 UPDFCB = 144 'updfcb(RetCode%,FcbAddr)
10159 CPYFILE = 147 'cpyfile(ReturnCode%, FcbSource, FcbDest, CountLow, CountHigh)
10160 NETTOD = 150 'nettod(time$)
10161 CLSMODE = 153 'clsmode(mode%)
10162 DRVMAP = 156 'drvmap(ReturnFlags%, drive%)
10163 RETSHL = 159 'retshl(RetCode%, Mode%)
10164 ASCLOG = 162 'asclog(RetCode%, Asciiz$)
10165 ASCULKF = 165 'asculkf(RetCode%, Asciiz$)
10166 ASCCLRF = 168 'ascclrf(RetCode%, Asciiz$)
10167 GETPSN = 171 'Get_PSN(StationNo%)
10168 GETSTA = 174 'Get_STA(Mode%,Segment%,Offset%)
10169 SETSERV = 177 'SetServ(Mode%,NewServ%,CurrServ%)
10170 MODSERV = 180 'ModServ(Mode%,NewServ%,RetCode%)
10180 GETDRV = 183 'GetDrv(Drive%)
10200 '
10210 ' Assign the segment address for the library to the variable LibSeg
10220 '
10230 def seg = 0
10240 suboff = peek(&h4f0)+(256*peek(&h4f1))
10250 subseg = peek(&h4f2)+(256*peek(&h4f3))
10260 LibSeg = subseg
10270 def seg
10280 ' be sure the resident module is in place so we don't blow up
10290 if LibSeg = 0 or suboff <> 0 then print "*** The resident library must be loaded before running this program ***":end
10300 '
10310 ' set the error mode so its more informative
10320 def seg = LibSeg
10330 NewMode% = 1
10340 call errmode(NewMode%)
10350 def seg
10500 '
10510 'set the lock mode
10520 '
10530 Func% = 1 'set to extended lock mode
10540 Mode% = 0 'we will get the current lock mode back here
10548 def seg = LibSeg
10550 call setlck(Func%,Mode%)
10555 def seg
10560 if Mode% <> 1 then print "Lock Mode not set. Press any key to continue. ";: while inkey$ = "": wend
10999 return
11000 ' do an extended open to get the file handle
11010 Filename$ = "FONE.DIR" + CHR$(0)
11020 Mode% = 66 'shareable, read/write
11030 FileHandle% = 0
11040 ErrCode% = 0
11045 def seg = LibSeg
11050 call xtndopn(Mode%, Filename$, FileHandle%, ErrCode%)
11055 def seg
11060 if ErrCode% <> 0 then print "Error on file open":stop
11999 return
12000 ' this routine calculates the byte offset and sets the lock length
12010 ' for use with the physical record locks
12020 ' - enter the routine with recno% set to the record to be locked -
12030 ' the first record = 0
12040 OffSet# = RecNo% * 64
12050 FindHi# = OffSet#/65536
12060 HiOffSet% = FindHi#
12070 if HiOffSet% > FindHi# then HiOffSet% = HiOffSet% - 1
12080 LoOffSet% = (FindHi# - HiOffSet%) * 65536!
12090 HiOffSet$ = str$(HiOffSet%)
12100 LoOffSet$ = str$(LoOffSet%)
12110 HiLockLen$ = str$(0)
12120 LoLockLen$ = str$(48)
12999 return
13000 '
13010 ' log and lock the record
13020 '
13022 recno% = recno% - 1 'set up recno so the first record is 0
13025 gosub 12000 ' set up the record data
13030 Flags% = 1 'set for a log and lock
13040 TimeOut% = 20
13050 ErrCode% = 0
13051 HiLockLen% = 0
13052 LoLockLen% = 48
13055 def seg = LibSeg
13060 call PRLH.Log(FileHandle%,HiOffSet%,LoOffSet%,HiLockLen%,LoLockLen%,Flags%,TimeOut%,ErrCode%)
13065 def seg
13070 if ErrCode% <> 0 then print "*** Record not available. Error *** " ErrCode%
13080 if ErrCode% <> 0 then print "Press any key to continue ";:while inkey$ = "":wend
13090 recno% = recno% + 1 'set recno back to its entry value
13999 return
14000 '
14010 ' clear the record lock
14020 '
14025 gosub 12000 ' set up the record data
14030 ErrCode% = 0
14035 def seg = LibSeg
14040 call PRLH.Clr(FileHandle%,HiOffset%,LoOffset%,ErrCode%)
14045 def seg
14999 return
15000 '
15010 ' error routine
15020 '
15030 print "*** This record is in use ***"
15040 noerr = 1
15999 resume next
16000 '
16010 ' error routine for header record
16020 '
16030 print "*** The header record is not available ***"
16040 print "Press any key to continue.";
16050 while inkey$ <> "": wend
16999 resume next
17000 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
17001 ' Get, Print and Validate numeric data
17002 '
17003 NUMBVAL$ = ""
17005 vlid$ = ""
17017 locate x%,(y% + len(numbval$))
17020 while vlid$ = "" or vlid$ = " ":vlid$ = inkey$:wend
17025 if (vlid$ = chr$(13)) and (len(numbval$) = 0) then 17999
17030 locate x%,(y% + len(numbval$)):print vlid$
17035 locate errloc%,10:print using "&";e$
17100 if (asc(vlid$) > 47) and (asc(vlid$) < 58) then 17200
17140 locate errloc%,10:print "*** Your entry is not numeric...please re-enter ***"
17160 goto 17005
17200 numbval$ = numbval$ + vlid$
17310 if len(numbval$) = vallen% then 17999
17320 goto 17005
17999 return